home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 6_2008-2009.ISO / data / zips / EGL_PointC215941872009.psc / PointCloud V1.1 / clsFileOBJ.cls < prev    next >
Text File  |  2009-08-06  |  7KB  |  222 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "clsFileOBJ"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. Option Explicit
  15. '
  16. ' Wavefront OBJ File parser
  17. '
  18. Dim hFile       As Long
  19. Private Lines() As String
  20.  
  21. Public Sub WriteOBJ(FileName As String)
  22.     
  23.     Dim strTemp     As String
  24.     Dim idx         As Long
  25.     Dim idxMesh     As Integer
  26.     Dim idxFace     As Long
  27.     Dim TotalNumFace As Long
  28.     Dim strX        As String
  29.     Dim strY        As String
  30.     Dim strZ        As String
  31.         
  32.     On Error GoTo err
  33.     
  34.     If FileExist(FileName) Then Kill FileName
  35.     
  36.     strTemp = "#" & vbCrLf & "# Create : EGL Point Cloud V1.0" & vbCrLf & "#" & vbCrLf
  37.     
  38.     hFile = FreeFile
  39.     Open FileName For Binary As hFile
  40.  
  41. 'Description
  42.         Put #hFile, , strTemp
  43.  
  44. 'Vertices
  45.         For idx = 1 To Mesh1.NumVertices
  46.             strX = GetVal(Mesh1.Vertices(idx).X)
  47.             strY = GetVal(Mesh1.Vertices(idx).Y)
  48.             strZ = GetVal(Mesh1.Vertices(idx).Z)
  49.             
  50.             
  51.             
  52.             
  53.             strTemp = "v  " & strX & " " & strY & " " & strZ & vbCrLf
  54.             Put #hFile, , strTemp
  55.         Next
  56.         strTemp = "# " & CStr(Mesh1.NumVertices) & " vertices" & vbCrLf & vbCrLf & "g Object" & vbCrLf
  57.         Put #hFile, , strTemp
  58.         
  59. 'Faces
  60.         For idxMesh = 1 To Mesh1.NumMeshs
  61.             For idxFace = 1 To Mesh1.Meshs(idxMesh).NumFaces
  62.                 With Mesh1.Meshs(idxMesh).Faces(idxFace)
  63.                     strTemp = "f " & CStr(.A) & " " & CStr(.B) & " " & CStr(.C) & vbCrLf
  64.                     Put #hFile, , strTemp
  65.                     TotalNumFace = TotalNumFace + 1
  66.                 End With
  67.             Next
  68.         Next
  69.         strTemp = "# " & CStr(TotalNumFace) & " faces" & vbCrLf & vbCrLf & "g " & vbCrLf
  70.         Put #hFile, , strTemp
  71.         
  72.     Close #hFile
  73.     Exit Sub
  74. err:
  75.     Close #hFile
  76. End Sub
  77.  
  78. Private Function GetVal(Val As Single) As String
  79.     
  80.     Val = Round(Val, 6)
  81.     GetVal = CStr(Val)
  82.     GetVal = Replace(GetVal, ",", ".")
  83.     
  84. End Function
  85.  
  86. Public Sub ReadOBJ(FileName As String)
  87.     
  88.     Dim strData As String
  89.     Dim idx     As Long
  90.     Dim dx      As Single
  91.     Dim dy      As Single
  92. '    Dim dmax    As Single
  93.     Dim char    As String
  94.     
  95.     On Error Resume Next
  96.     
  97.     'Reset
  98.     LoadComplete = False
  99.     Erase Lines
  100.     Mesh1.NumMeshs = 0
  101.     Mesh1.NumVertices = 0
  102.     Erase Mesh1.Meshs
  103.     Erase Mesh1.Vertices
  104.     
  105.     hFile = FreeFile
  106.     Open FileName For Input As #hFile
  107.         strData = Input(LOF(1) - 1, #hFile)
  108.     Close #hFile
  109.     Lines = Split(strData, vbLf)
  110.     With Mesh1
  111.         Erase Dots1.Dots
  112.         Erase .Vertices
  113.         .NumMeshs = 1
  114.         ReDim .Meshs(.NumMeshs)
  115.         
  116.         For idx = 0 To UBound(Lines)
  117.             char = Left(Lines(idx), 1)
  118.             Select Case char
  119.                 Case "v"
  120.                     .NumVertices = .NumVertices + 1
  121.                     Dots1.NumDot = .NumVertices
  122.                     ReDim Preserve Mesh1.Vertices(1 To .NumVertices)
  123.                     ReDim Preserve Dots1.Dots(1 To .NumVertices)
  124.                     .Vertices(.NumVertices) = GetVectorValue(Lines(idx))
  125.                     Dots1.Dots(.NumVertices).Vector = .Vertices(.NumVertices)
  126.                     Dots1.Dots(.NumVertices).Visible = True
  127.                 Case "f":
  128.                     With .Meshs(1)
  129.                         .NumFaces = .NumFaces + 1
  130.                         ReDim Preserve .Faces(.NumFaces)
  131.                         ReDim Preserve .Normals(.NumFaces)
  132.                         .Faces(.NumFaces) = GetFaceValue(Lines(idx))
  133.                         .Normals(.NumFaces) = _
  134.                             CalculateNormal(Dots1.Dots(.Faces(.NumFaces).A).Vector, _
  135.                                             Dots1.Dots(.Faces(.NumFaces).B).Vector, _
  136.                                             Dots1.Dots(.Faces(.NumFaces).C).Vector)
  137.                     End With
  138.             End Select
  139.         Next
  140.         .Meshs(1).NormalsT = .Meshs(1).Normals
  141.     End With
  142.     With Dots1
  143.         Call CalculateBox(.Dots, .Box, .Center)
  144.         
  145. 'move center
  146.         For idx = 1 To .NumDot
  147.             .Dots(idx).Vector = VectorSubtract(.Dots(idx).Vector, .Center.Vector)
  148.         Next idx
  149.         
  150.         For idx = 1 To 8
  151.             .Box(idx).Vector = VectorSubtract(.Box(idx).Vector, .Center.Vector)
  152.         Next idx
  153.         
  154.         .Center.Vector = VectorSet(0, 0, 0)
  155.         
  156. 'scale screen
  157.         dx = .Box(7).Vector.X - .Box(1).Vector.X
  158.         dy = .Box(7).Vector.Y - .Box(1).Vector.Y
  159.         If dx > dy Then
  160.             MaxH = dx
  161.         Else
  162.             MaxH = dy
  163.         End If
  164.         
  165.         Position.Sca = (cHeight / MaxH) * 0.9 ' 0.9 bigness 90%
  166.         For idx = 1 To .NumDot
  167.             .Dots(idx).Vector = VectorSca(.Dots(idx).Vector, Position.Sca)
  168.         Next idx
  169.         For idx = 1 To 8
  170.             .Box(idx).Vector = VectorSca(.Box(idx).Vector, Position.Sca)
  171.         Next idx
  172.         .ClpZ = (.Box(7).Vector.Z - .Box(1).Vector.Z) \ 100
  173.         
  174.     End With
  175.     Call ResetMeshParameters
  176.     Call ResetCameraParameters
  177.     Call ResetLightParameters
  178.     LoadComplete = True
  179.  
  180. End Sub
  181.  
  182. Private Function GetVectorValue(Line As String) As VECTOR4
  183.  
  184.     Dim Value As String
  185.     Dim Segments() As String
  186.     
  187.     Segments = Split(Line, " ")
  188.     
  189. 'X Value
  190.     Value = Segments(UBound(Segments) - 2)
  191.     GetVectorValue.X = CSng(Replace(Value, ".", ","))
  192. 'Y Value
  193.     Value = Segments(UBound(Segments) - 1)
  194.     GetVectorValue.Y = CSng(Replace(Value, ".", ","))
  195. 'Z Value
  196.     Value = Segments(UBound(Segments))
  197.     GetVectorValue.Z = CSng(Replace(Value, ".", ","))
  198. 'W Value
  199.     GetVectorValue.W = 1
  200.  
  201. End Function
  202.  
  203. Private Function GetFaceValue(Line As String) As FACE
  204.  
  205.     Dim Value As String
  206.     Dim Segments() As String
  207.     
  208.     Segments = Split(Line, " ")
  209.     
  210. 'A Value
  211.     Value = Segments(UBound(Segments) - 2)
  212.     GetFaceValue.A = CLng(Value)
  213. 'B Value
  214.     Value = Segments(UBound(Segments) - 1)
  215.     GetFaceValue.B = CLng(Value)
  216. 'C Value
  217.     Value = Segments(UBound(Segments))
  218.     GetFaceValue.C = CLng(Value)
  219.  
  220. End Function
  221.  
  222.